perm filename T3.F4[M11,LCS]4 blob sn#409390 filedate 1979-01-13 generic text, type T, neo UTF8
00100	      SUBROUTINE MSCAN
00200	CXX	DOUBLE PRECISION JFLNM,INST,INAM
00300	      DIMENSION TONES(21)
00400		COMMON LL  /P/W(1)
00500	CIN   COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,4),K
00600	CC      COMMON /I/I(1) /TR/RX(80),JX(80),LX(12),K 
00700		COMMON /ROUT/I(200),RX(80),JX(80) /TR/LX(12),K
00800	     1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
00900	     1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
01000	     1,ENDX,J  /KNAM/IPLAY,JFLNM
01100		1 /INST/INST(1)
01200	      COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT
01300	      INTEGER RPR
01400	      EQUIVALENCE (LESS,LX(9)),(W1,W(1)),(W2,W(2)),(W3,W(3)),(W4,W(4)),
01500	     1 (RX2,RX(3)),(P2,P(2)),(RX3,RX(5)),(I3,I(3))
01600	     1 ,(ISEMI,LX(2)),(IAST,LX(3))
01700	     1,(LPR,LX(11)),(RPR,LX(12)),(ICOM,LX(10)),(LAROW,LX(7))
01800	      DATA TONES/246.945,261.62,277.18,277.8,293.66,311.13,311.13,
01900	     1 329.63,349.23,329.63,349.23,369.99,369.99,
02000	     1 391.99,415.31,415.31,440.0,466.16,466.16,493.89,523.24/
02100	
02200	C**** CODE NUMS. 1=OUT 2=OSC 3=AD2 4=RAN 5=END 6=STR 7=AD3 8=AD4 9=MLT
02300	C**** 10=DIV 11=RAH 12=END 13=REV 14=OPT 15=NOS 16=SUB 17=INP  18=COS
02400	C**** B1=101 ETC.  P1=201 ETC.  F1=301 ETC. FREQ-PARAMS=600S, DURS=700S.
02500	C**** 400=PLAY 401=FINI 402=SRATE 403=NCHNS 404=PRINT 405=CHA 
02600	C**** 407=SRT 409=GEN 410=SEG 411=SIN  412=INS 413=UNIT GEN.
02700	C**** 500=CF 501=C 502=CS 503=DF 504=D 505=DS 506=EF 507=E 508=ES 509=FF
02800	C**** 510=F 511=FS 512=GF 513=G 514=GS 515=AF 516=A 517=AS 518=BF 519=B 520=BS
02900	
03100		JSEM=0
03200	C IS THIS NEEDED HERE?
03300	C JSEM=0 FOR 'PLAY' OR ASSIGNMENT ( P3←440;,  A=444; ETC.)
03400	      LL=1
03500	      INS=-1
03600	34      J=J+2      
03700	2324	FORMAT(1X20F10.3/)
03800	2325	FORMAT(1X20I/)
03900	2323	FORMAT(1X20A1/)
04000	      IXJ=JX(J)      
04100	      IPP=0             
04200	C!FOR 'P3←333;' ETC.
04300	      IOP=-1
05000	9      IF(J.GE.MM)GO TO 1001  
05100	      IF(RX(J+1).EQ.-9999.0)GO TO 11  
05200	C!*** SKIP IF NUMBER
05300	      IF(IGEN.GT.0)GO TO 450
05400	C IGEN=2=INSIDE AN INST. DEFINITION.
05500	
05600	C!***** LOOK FOR SPECIAL WORDS
05700		IF(IXJ/400.NE.1)GO TO 402
05800		K=IXJ-399
05900	C			   PRINT
06000	       GO TO (13,13,304,303,302,303,4,505,505,422,422,422,32)K
06100	C 	(PLAY) FINI SRAT NCHN   CHA   SRT     GEN SEG SIN INS
06200	32      W1=2
06300		IXJ=13
06400		JX(J)=13
06500	      IGEN=2
06600	      GO TO 424
06700	505      JK=4         
06800	C !**** FOR SRT
06900	      IF(K.NE.4)JK=2      
07000	      JK=J+JK
07100	      GO TO 304
07200	
07300	450	K=IXJ
07400	C** HERE FOR INST DEFINITIONS.
07500	CC	IF(K.LE.13.AND.K.GT.0)GO TO(425,425,425,425,425
07600	CC	1,425,425,425,425,425,425,411),K
07700	CC	IF(K.EQ.14)GO TO 425
07800	C 14='OPT' USER-ADDED UNIT GENERATOR.
07900		IF(K.EQ.12)GO TO 412
08000		IF(K.GT.0)GO TO 425
08800	CC503      JSEM=0
08900	CC      J=MM
09000	CC      RETURN   
09050		GO TO 1001
09100	504      FORMAT(' UNKNOWN SYMBOL ',A4)
09200	412       LL=3
09300	      IGEN=1   
09400	C!*** =1 IS FLAG TO CHANGE IT TO -1
09500	      J=MM
09600	      INS=-1
09700	      GO TO 10  
09800	422      W1=3   
09900	C!***** GEN
10000		IF(K.GT.10)W1=K-4
10100	C SEG=11, SIN=12  AT THIS POINT.
10200	      IGEN=0
10300	424      INS=-1
10400	      LL=2
10500	      GO TO 36
10600	425      W3=K+100
10700	436      LL=4  
10800	      GO TO 36
10900	
11000	CC3      J=J+2      
11100	C 'PLAY' IS NO LONGER NEEDED.
11200	C   !**** FOUND 'PLAY;'
11300	CC      IF(JX(J).NE.ISEMI)CALL ERR(1)
11400	C FLAG FOR 'TRANS' 
11500	CXXX  IPLAY=-1
11700	CC      IF(J.LT.MM)GO TO 34
11900	CC	PAUSE 'BEFORE LABEL 4'
12000	CC      RETURN
12100	4      JL=LL
12200	      JOP=IOP
12300	      J=J+2
12400	      IF(JX(J).NE.LPR)CALL ERR(2)
12500	      IOP=-1
12600	      GO TO 36  
12700	C!**FIND NUM UP TO THE COMMA
12800	302      LL=1
12900	      IPRNT=-1    
13000	C!***** FOR 'PRINT' FEATURE
13100	      GO TO 36
13200	304      SRATE=RX(J+4)
13300	      J=J+6
13400	      RMAG=512./SRATE
13500	      W3=4
13600	      W4=SRATE
13700	351      W1=11
13800	      W2=0
13900	      IGEN=0
14000	      LL=5
14050	C JSEM=-1  = SEND DATA BACK TO MUS5,PASS3.
14100	10	JSEM=-1
14200		RETURN
14300	CCC303      IF(IXJ.EQ.405)J=J-2
14400	303   RNCHN=RX(J+4)    
14500	C!**** FOR NCHNS←N;  OR  CHA ← N;
14600	      J=J+6
14700	CC      IF(RX(JK+1).NE.-9999.0)JK=JK+2  
14800	C!*** SKIP A COMMA
14900	CC      IF(JX(JK+2).EQ.ISEMI)GO TO 352  
15000	C!*** FOR NCHNS←n;
15100	352      W3=8            
15200	C!*** FOR NCHNS
15300	      W4=RNCHN-1
15400	      GO TO 351
16000	36      J=J+2      
16100	      IF(J.GT.MM)GO TO 1001        
16200	C!******  50 = DONE
16300	CC      JK=J*2
16400	CCC      IXJ=JX(J)      
16500	CX	TYPE 2324,RX(J+1)
16600	CX	TYPE 2323,IXJ
16700	CX	TYPE 2325,IXJ,IOP,IGEN
16800	CX	PAUSE 'LABEL 36'
16900		IF(IPLAY.LT.0)P(LL-3)=W(LL-1)
17100	C  **** LL HAD BETTER ALWAYS BE >3 HERE.
17200	C  FILL UP PARAM LIST WITH DATA FOLLOWING INST NAME.
17300	1002  	IXJ=JX(J)
17350		IF(IXJ.NE.ISEMI)GO TO 1
17500		IPLAY=0
17600	1000      IF(IPP.EQ.0)GO TO 10
17700	      P(IPP)=W1
17800	      LL=1
17900	      IPP=0
18000	      IF(J.LT.MM)GO TO 34  
18100	CC      IF(J.LT.MM)GO TO 30  
18200	      INS=-1   
18300	C!*** I HOPE THIS IS THE RIGHT PLACE FOR THIS.
18600	CX	PAUSE 'LABEL 1001'
18700	1001      JSEM=0
18800		RETURN
18900	
19000	1      IF(RX(J+1).NE.-9999.0)GO TO 2
19100	CX	TYPE 2325,IOP
19200	CX	PAUSE 'LABEL 1'
19300	11	IF(IOP.LT.0)GO TO 40
19400	      IF(IOP.NE.6)GO TO 12
19500	      RX(J)=-RX(J)  
19600	C!*** IOP=6 MEANS MINUS WITH COMMA IN FRONT
19700	      W(LL)=RX(J)
19800	      LL=LL+1
19900	      GO TO 14
20000	12	CALL ARITH(RX(J),W,LL)
20100	14      IOP=-1    
20200	C!*** RESET OPERATOR FLAG
20300	      GO TO 36   
20400	C!*** USE PARENTH'S FOR COMPOSITE EXPRESSIONS!!!!
20500	
20600	40	     W(LL)=RX(J)
20700	38      LL=LL+1
20800	      IF(IOP.LT.0)GO TO 36
20900	C IOP = NEG = NO OPERATOR BEFORE THIS ITEM.
21000	      LL=LL-1
21100	380      CALL ARITH(W(LL),W,LL)
21200	      GO TO 14
21300	
21500	C!**** READING CONTINUATION LINE.
21600	402	IF(IXJ.GE.0)GO TO 33
21700	C NEXT TRIES TO FIND INST. NAME.
21800	CIN	NA=-1-IXJ
21900	CIN	M=JX(J+1)
22000	C NA POINTS TO SPOT IN I ARRAY, M IS WDCNT.
22100		CALL PACKER(INAM,I(-IXJ))
22200		DO 233 IK=1,INUM
22300	233	IF(INST(IK).EQ.INAM)GO TO 333
22400		TYPE 504,INAM
22500		GO TO 33
22600	CIN	DO 133 IK=1,INUM
22700	CIN	DO 233 II=1,M
22800	CIN233	IF(INST(IK,II).NE.I(II+NA))GO TO 133
22900	C NOW WE FOUND AN INST. NAME.
23000	C******* INST NAMES CANNOT HAVE SAME STRING OF 1ST LETTERS AS OTHER THINGS.
23100	333	IPLAY=-1
23200	C FLAG TO START FILLING PARAMS.
23310	      W2=INSNUM(IK)      
23320	C!**** W IS P ARRAY IN MUSIC5
23330	      LL=3      
23340	C!**** W2 AND W3 WILL BE EXCHANGED LATER
23360		J=J+2
23380		GO TO 1002
23400	CC333	IF(M.EQ.4)GO TO 35
23500	CC	M=M+1
23600	CC	IF(INST(IK,M).EQ.0)GO TO 333
23700	CIN133	CONTINUE
23800	33    INS=2      
23900	C! NEXT IS SOMETHING OUTSIDE OF INST. AND PARAMS.
24000	
24100	2      IF(IGEN.GT.0)GO TO 427
24200		IF(IXJ.GT.520)GO TO 341
24300		IF(IXJ.LT.500)GO TO 427
24400	C NOW FOUND A NOTE
24500		K=IXJ-499
24600	      W(LL)=TONES(K)
24700	      GO TO 38
24800	C!***** FINDS NOTE IN SCALE
24900	
25000	C!****** FIND A PARAM NUM.
25100	427	IF(IXJ.GE.300)GO TO 307
25200		IF(IXJ.LT.200)GO TO 344
25300		K=IXJ-200
25400	C NOW K HAS PARAM NUM.
25500	      IF(INS.LE.0)GO TO 340
25600	      JK=J+2      
25700	      IF(JX(JK).NE.LAROW)GO TO 340
25800	      IPP=K
25900	      LL=1
26000	      J=JK      
26100	      GO TO 36
26200	340      W(LL)=P(K)      
26300	C!***** FOUND Pn
26400	      IF(IPRNT.LT.0)GO TO 38
26500	      IF(IGEN.GT.0)W(LL)=K+2.  
26600	C!*** PARAM NUMS ARE 2 LESS THAN IN BOOK.
26700	      GO TO 38    
26800	C!**** P4 IS CHANGED TO 6
26900	307    IF(IXJ.GE.400)GO TO 344
27000	
27100		IF(IXJ/300.NE.1)GO TO 344
27200		JL=IXJ-300
27300	      IF(IGEN.GT.0)JL=-JL-100      
27400	C!*** FOR Fn IN INST DEFINITION
27500	      W(LL)=JL
27600	      GO TO 38
27700	
27800	344      IF(IGEN.LE.0)GO TO 341
27900	C*** FOR B1, ETC. IN INST. DEFS.
28000		IF(IXJ/100.NE.1)GO TO 341
28100		 W(LL)=100-IXJ
28200	      GO TO 38
28300	
28400	341      DO 39 K=3,6
28500	      IF(LX(K).NE.IXJ)GO TO 39
28600		IF(K.NE.3)GO TO 342
28700		IF(JX(J+2).NE.IAST)GO TO 342
28800	C NOW FOUND 'X**Y', =X TO THE POWER OF Y
28900		K=7
29000		J=J+2
29100	342      IOP=K-2
29200	C IOP NUMS ARE: 1=+  2=-  3=*  4=/  5=**
29300	      JK=JX(J-2)
29400	      IF(JK.EQ.ICOM)IOP=6 
29500	C!** COMMA DISABLES NEXT OPERATOR
29600	      IF(JK.EQ.LAROW)IOP=6 
29700	C!**  ← DISABLES NEXT OPERATOR
29800	      IF(JK.EQ.LPR)IOP=6 
29900	C!** LFT PARENTH. DISABLES NEXT OPERATOR
30000	      GO TO 36
30100	39      CONTINUE
30200	308      IF(IXJ.EQ.LAROW)GO TO 36   
30300	C!*** PASS LEFT ARROW
30400		IF(IXJ.EQ.RPR)GO TO 500
30500		IF(IXJ.EQ.LPR)GO TO 500
30600	C LEFT AND RIGHT PARENTHESES
30700		IF(IXJ.NE.402)GO TO 510
30800	C 402=SRATE
30900		W(LL)=SRATE
31000	335      LL=LL+1
31100	      GO TO 36
31200	C**** OR SHOULD NEXT BE 403???
31300	510      IF(IXJ.NE.403)GO TO 511
31400	C 403-'NCHNS'
31500	      W(LL)=RNCHN
31600	      GO TO 335
31700	511      IF(IXJ.NE.ICOM)RETURN
31710	CC511      IF(IXJ.NE.ICOM)GO TO 503       
31800	C!***** UNKNOWN CHAR.
31900	500      IF(IXJ.NE.LPR)GO TO 501
32000	      KOP=IOP
32100	      IOP=-1
32200	      JL=LL      
32300	C!**** SAVE VARIOUS POINTERS WHEN INSIDE PARENTHS.
32400	      GO TO 36
32500	501      IF(IXJ.NE.RPR)GO TO 502
32600	C!*** GET BACK STUFF
32700	      IOP=KOP
32800	      IF(IOP.LT.0)GO TO 36
32900	      LL=JL
33000	      GO TO 380      
33100	C!GO DO ARITHMETIC
33200	502      IF(IPRNT)GO TO 36     
33300	C!**** FOUND COMMA IN PRINT STATEMENT.
33400	5      IF(JX(J-2).NE.ICOM)GO TO 132
33500	433      W(LL)=P(LL-2)   
33600	C!** ONLY CARES ABOUT 2 COMMAS IN A ROW
33700	      GO TO 335
33800	132      IF(INS.GE.0)GO TO 36
33900	      IF(LL.EQ.3)GO TO 433      
34000	C!*** =3 MEANS COMMA FOR P1.
34100	      GO TO 36
34200	
34300	13      LL=2
34600	      W1=6
34700	CC      W2=ENDX+.5   
34800		W2=ENDX
34900	C!***** ENDX IS P1+P2 OF THE LONGEST LASTING INST.
35000	      IF(JPRNT)TYPE 51,LL,W1,W2
35100	130      J=MM
35300	C!*** WON'T READ LINE BEYOND 'FINISH;'  ***************
35400	      ENDX=-1
35500	51      FORMAT(I3,35F10.3)
35600	      END
35700